home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / TURBOPASCAL WIN / OWLDEMOS.PAK / TTDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-08  |  13KB  |  426 lines
  1. {***************************************************}
  2. {                                                   }
  3. {   Turbo Pascal for Windows                        }
  4. {   Windows 3.1 TrueType Font Demonstration Program }
  5. {                                                   }
  6. {   Copyright (c) 1992 by Borland International     }
  7. {                                                   }
  8. {***************************************************}
  9.  
  10. {$N+}
  11.  
  12. program TrueTypeDemo;
  13.  
  14. { This program demonstrates some of the flexibility of the
  15.   TrueType font system for Windows 3.1 by generating a complex
  16.   display of rotated text.  The Font Selection dialog from the
  17.   Common Dialogs DLL is also demonstrated.
  18. }
  19.  
  20. {$R TTDEMO}
  21.  
  22. uses WinTypes, WinProcs, WObjects, Strings, Win31, CommDlg, BWCC;
  23.  
  24. const
  25.  
  26. { Resource IDs }
  27.  
  28.   id_Menu  = 100;
  29.   id_About = 100;
  30.   id_Icon  = 1;
  31.  
  32. { Menu command IDs }
  33.  
  34.   cm_Shadows        = 201;
  35.   cm_Fonts          = 203;
  36.   cm_HelpAbout      = 300;
  37.  
  38. type
  39.  
  40. { Application main window }
  41.  
  42.   PFontWindow = ^TFontWindow;
  43.   TFontWindow = object(TWindow)
  44.  
  45.     MainFontRec,
  46.     LogoFontRec,
  47.     BorlandFontRec    : TLogFont;
  48.  
  49.     FanColor          : array [0..9] of TColorRef;
  50.     ShadowAll         : Boolean;
  51.     Rendering         : Boolean;
  52.  
  53.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  54.     function  GetClassName: PChar; virtual;
  55.     procedure GetWindowClass( var WC: TWndClass); virtual;
  56.  
  57.     procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
  58.  
  59.     procedure CMHelpAbout(var Msg: TMessage);
  60.       virtual cm_First + cm_HelpAbout;
  61.     procedure CMShadows(var Msg: TMessage);
  62.       virtual cm_First + cm_Shadows;
  63.     procedure CMFonts(var Msg: TMessage);
  64.       virtual cm_First + cm_Fonts;
  65.     procedure WMGetMinMaxInfo(var Msg: TMessage);
  66.       virtual wm_First + wm_GetMinMaxInfo;
  67.     procedure WMSize(var Msg: TMessage);
  68.       virtual wm_First + wm_Size;
  69.   end;
  70.  
  71. { Application object }
  72.  
  73.   TFontApp = object(TApplication)
  74.     procedure InitMainWindow; virtual;
  75.   end;
  76.  
  77. { Initialized globals }
  78.  
  79. const
  80.   DemoTitle: PChar = 'TrueType Demo';
  81.  
  82. { Global variables }
  83.  
  84. var
  85.   App: TFontApp;
  86.  
  87. { TFontWindow Methods }
  88.  
  89. { Constructs an instance of the TFontWindow.  Sets up the window's menu,
  90.   then initializes the Logical Font structures for the three fonts to
  91.   be used in the demo.
  92. }
  93. constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  94. begin
  95.   TWindow.Init(AParent, ATitle);
  96.   Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  97.  
  98. { Initialize the logical font record for the 'fan' text.  Default
  99.   is TimesNewRoman.
  100. }
  101.   with MainFontRec do
  102.   begin
  103.     lfHeight        := 26;
  104.     lfWidth         := 10;
  105.     lfEscapement    := 0;
  106.     lfOrientation   := 0;
  107.     lfWeight        := fw_Bold;
  108.     lfItalic        := 0;
  109.     lfUnderline     := 0;
  110.     lfStrikeOut     := 0;
  111.     lfCharSet       := ANSI_CharSet;
  112.     lfOutPrecision  := Out_Default_Precis;
  113.     lfClipPrecision := Clip_Default_Precis;
  114.     lfQuality       := Proof_Quality;
  115.     lfPitchAndFamily:= Variable_Pitch or FF_Roman;
  116.     StrCopy(lfFaceName,'Times New Roman');
  117.   end;
  118.  
  119.   LogoFontRec := MainFontRec;
  120.  
  121.   BorlandFontRec:= MainFontRec;
  122.   with BorlandFontRec do
  123.   begin
  124.     lfHeight:= 60;
  125.     lfWidth := 0;           {Choose best width for this height }
  126.     lfWeight:= 900;
  127.     StrCopy(lfFaceName, 'Arial');
  128.   end;
  129.  
  130. { Initialize an array of colors used to color the fan text }
  131.   FanColor[0] := RGB(255,0,0);
  132.   FanColor[1] := RGB(128,0,0);
  133.   FanColor[2] := RGB(255,128,0);
  134.   FanColor[3] := RGB(80,80,0);
  135.   FanColor[4] := RGB(80,255,0);
  136.   FanColor[5] := RGB(0,128,0);
  137.   FanColor[6] := RGB(0,128,255);
  138.   FanColor[7] := RGB(0,0,255);
  139.   FanColor[8] := RGB(128,128,128);
  140.   FanColor[9] := RGB(255,0,0);
  141.  
  142.   ShadowAll := False;
  143.   Rendering := False;
  144. end;
  145.  
  146. { Responds to repaint requests by completely redrawing the
  147.   fanned-text demo display.
  148. }
  149. procedure TFontWindow.Paint(DC: HDC; var PS: TPaintStruct);
  150. const
  151.   ArcText     = 'TrueType';
  152.   FanText     = 'Turbo Pascal for Windows';
  153.   BorlandText = 'Borland';
  154.   WaitText    = 'Windows is rendering fonts...';
  155.   Radius      = 100;   { Controls circle about which text is fanned }
  156.  
  157.   Deg2Rad : Extended = PI / 18;    { Used for angle calculations }
  158. type
  159.   TTextExtent = record
  160.     W, H: Word;
  161.   end;
  162. var
  163.   FontRec   : TLogFont;
  164.   FontMetric: TOutlineTextMetric;
  165.   FontHeight: Integer;
  166.   d         : Word;
  167.   x, y, j, k: Integer;
  168.   Theta     : Real;
  169.   P         : PChar;
  170.   CRect     : TRect;
  171.   BaseWidth,
  172.   DesiredExtent,
  173.   FanTextLen: Word;
  174.   TextExt   : TTextExtent;
  175. begin
  176.   P := ArcText;
  177.   FanTextLen := StrLen(FanText);
  178.  
  179.   SaveDC(DC);
  180.  
  181.   if Rendering then
  182.     { Display a message that Windows is rendering fonts, please wait... }
  183.     SetWindowText(HWindow, WaitText);
  184.  
  185. { Create the "TT" logo, in black-on-gray, at the upper left-hand
  186.   corner of the window.
  187. }
  188.   FontRec := LogoFontRec;
  189.   SetBkMode(DC, Transparent);
  190.   SetTextColor(DC, RGB(128, 128, 128));
  191.   FontRec.lfHeight:= FontRec.lfHeight * 2;
  192.   FontRec.lfWidth := Trunc(FontRec.lfWidth * 2.1);
  193.   SelectObject(DC, CreateFontIndirect(FontRec));
  194.   TextOut(DC, 18, 5, 'T', 1);
  195.   SetTextColor(DC, RGB(0, 0, 0));
  196.   TextOut(DC, 32, 13, 'T', 1);
  197.  
  198. { Next, get the TextMetrics for the font to be used as the fan
  199.   text.  This will be used to control the fanning, and to size
  200.   the window.
  201. }
  202.   GetClientRect(HWindow, CRect);
  203.   FontRec := MainFontRec;
  204.   DeleteObject(SelectObject(DC, CreateFontIndirect(FontRec)));
  205.   GetOutlineTextMetrics(DC, SizeOf(FontMetric), @FontMetric);
  206.   FontHeight := FontMetric.otmTextMetrics.tmHeight;
  207.   SetViewportOrg(DC, FontHeight+2, 0);
  208.   Dec(CRect.Right, FontHeight+2);
  209.   BaseWidth := LoWord(GetTextExtent(DC, FanText, FanTextLen));
  210.  
  211. { Always draw the inner circle around which the text will be
  212.   fanned (draw two circles for nice effect).  If Alignment
  213.   Marks are on, then draw the outer circle as well.  Use a Null
  214.   brush to avoid writing over text.
  215. }
  216.   SelectObject(DC, GetStockObject(Null_Brush));
  217.   Ellipse(DC, -(Radius-5),  -(Radius-5),  (Radius-5),  Radius-5);
  218.   Ellipse(DC, -(Radius-10), -(Radius-10), (Radius-10), Radius-10);
  219.  
  220.   SetTextColor(DC, FanColor[0]);
  221.   for d:= 27 to 36 do
  222.   begin
  223.     x := Round(Radius * cos( d * Deg2Rad));
  224.     y := Round(Radius * sin(-d * Deg2Rad)); { -d because y axis is inverted }
  225.  
  226.     Theta := -d * Deg2Rad;
  227.     if X <> 0 then
  228.       Theta := ArcTan((CRect.Right / CRect.Bottom) * (Y / X));
  229.  
  230.     j := Round(CRect.Right  * cos(Theta));
  231.     k := Round(CRect.Bottom * sin(Theta));
  232.  
  233. { Calculate how long the displayed string should be.
  234. }
  235.     DesiredExtent:= Round(Sqrt(Sqr(x*1.0 - j) + Sqr(y*1.0 - k))) - 5;
  236.     FontRec := MainFontRec;
  237.     FontRec.lfEscapement:= d * 100;
  238.     FontRec.lfWidth     := Trunc(FontMetric.otmTextMetrics.tmAveCharWidth *
  239.       (DesiredExtent / BaseWidth));
  240.     DeleteObject(SelectObject(DC, CreateFontIndirect(FontRec)));
  241.     Longint(TextExt) := GetTextExtent(DC, FanText, FanTextLen);
  242.  
  243. { Shave off some character width until the string fits
  244. }
  245.     while (TextExt.W > DesiredExtent) and (FontRec.lfWidth <> 0) do
  246.     begin
  247.       Dec(FontRec.lfWidth);
  248.       DeleteObject(SelectObject(DC, CreateFontIndirect(FontRec)));
  249.       Longint(TextExt) := GetTextExtent(DC, FanText, FanTextLen);
  250.     end;
  251.  
  252. { Expand the string if necessary to make it fit the desired extent.
  253. }
  254.     if TextExt.W < DesiredExtent then
  255.       SetTextJustification(DC, DesiredExtent - TextExt.W, 3);
  256.  
  257. { If shadowing is enabled, draw an underlying copy of the string
  258.   in black.  Then, draw the text in the actual color.
  259. }
  260.     if ShadowAll then
  261.     begin
  262.       SetTextColor(DC, RGB(0, 0, 0));
  263.       TextOut(DC, x+2, y+1, FanText, FanTextLen);
  264.     end;
  265.     SetTextColor(DC, FanColor[d - 27]);
  266.     TextOut(DC, x, y, FanText, FanTextLen);
  267.     SetTextJustification(DC, 0, 0);  {Clear justifier's internal error
  268.                                       accumulator}
  269.  
  270.     if P[0] <> #0 then
  271.     begin
  272.       FontRec := LogoFontRec;
  273.       FontRec.lfEscapement:= (d + 10) * 100;
  274.       FontRec.lfWidth     := 0;
  275.       DeleteObject(SelectObject(DC, CreateFontIndirect(FontRec)));
  276.       SetTextColor(DC, 0);
  277.       x := Round((Radius - FontHeight - 5) * cos( d * Deg2Rad));
  278.       y := Round((Radius - FontHeight - 5) * sin(-d * Deg2Rad));
  279.       TextOut(DC, x, y, P, 1);
  280.       inc(P);
  281.     end;
  282.   end;      {for d:= 27 to 36}
  283.  
  284. { Render the Borland logo in the bottom-right corner.
  285. }
  286.   DeleteObject(SelectObject(DC, CreateFontIndirect(BorlandFontRec)));
  287.   Longint(TextExt) := GetTextExtent(DC, BorlandText, StrLen(BorlandText));
  288.   SetTextColor(DC, RGB(0, 0, 0));
  289.   TextOut(DC, CRect.Right - TextExt.W, CRect.Bottom - TextExt.H,
  290.               BorlandText, StrLen(BorlandText));
  291.   SetTextColor(DC, RGB(255, 0, 0));
  292.   TextOut(DC, CRect.Right - TextExt.W - 5, CRect.Bottom - TextExt.H,
  293.               BorlandText, StrLen(BorlandText));
  294.  
  295. { Restore the window caption to the proper title string, then clear the
  296.   rendering flag.  The flag will be set again when the window is resized.
  297. }
  298.   if Rendering then
  299.   begin
  300.     SetWindowText(HWindow, Attr.Title);
  301.     Rendering := False;
  302.   end;
  303.  
  304.   DeleteObject(SelectObject(DC, GetStockObject(System_Font)));
  305.   RestoreDC(DC, -1);
  306. end;
  307.  
  308. { Posts the About box dialog from the Help Menu.
  309. }
  310. procedure TFontWindow.CMHelpAbout(var Msg: TMessage);
  311. begin
  312.   Application^.ExecDialog(New(PDialog, Init(@Self, PChar(id_About))));
  313. end;
  314.  
  315. { Toggles the state of the text shadow display.  Repaints
  316.   the window to show the new state.
  317. }
  318. procedure TFontWindow.CMShadows(var Msg: TMessage);
  319. begin
  320.   ShadowAll := not ShadowAll;  { Set data field for repaint }
  321.   if ShadowAll then
  322.     CheckMenuItem(Attr.Menu, cm_Shadows, mf_ByCommand or mf_Checked)
  323.   else
  324.     CheckMenuItem(Attr.Menu, cm_Shadows, mf_ByCommand or mf_UnChecked);
  325.  
  326. { If the new state is to not show shadows, then clear the window
  327.   before repainting.  Otherwise, don't clear so that alignment
  328.   marks seem to appear without the text redrawing (it will actually
  329.   be redrawing over itself).
  330. }
  331.   InvalidateRect(HWindow, nil, not ShadowAll);
  332. end;
  333.  
  334. { Posts the ChooseFont dialog from CommDlg.tpu to allow the
  335.   user to select a new font.
  336. }
  337. procedure TFontWindow.CMFonts(var Msg: TMessage);
  338. var
  339.   ChooseRec: TChooseFont;
  340.   FontRec  : TLogFont;
  341. begin
  342.   FontRec := MainFontRec;
  343.   FillChar(ChooseRec, Sizeof(ChooseRec), #0);
  344.   with ChooseRec do
  345.   begin
  346.     lStructSize:= SizeOf(TChooseFont);
  347.     HWndOwner  := HWindow;
  348.     Flags      := cf_AnsiOnly or cf_TTOnly or cf_ScreenFonts
  349.                   or cf_EnableTemplate or cf_InitToLogFontStruct;
  350.     nFontType  := Screen_FontType;
  351.     lpLogFont  := @FontRec;
  352.     lpTemplateName := 'FontDlg';
  353.     ChooseRec.hInstance := System.hInstance;
  354.   end;
  355. { Post the dialog and check the result.  If OK clicked, then
  356.   only get the font name - we don't care what size the user
  357.   selected, since the demo uses canned sizes.  Invalidate the
  358.   window to redraw with the new font.
  359. }
  360.   if ChooseFont(ChooseRec) then
  361.   begin
  362.     StrCopy(MainFontRec.lfFaceName, FontRec.lfFaceName);
  363.     MainFontRec.lfWeight := FontRec.lfWeight;
  364.     MainFontRec.lfItalic := FontRec.lfItalic;
  365.     Rendering := True;
  366.     InvalidateRect(HWindow, nil, True);
  367.   end;
  368. end;
  369.  
  370. { Provides Windows with a minimum size for the application window,
  371.   so that the fonts don't get too small.
  372. }
  373. procedure TFontWindow.WMGetMinMaxInfo(var Msg: TMessage);
  374. type
  375.   TPointArray = array [0..4] of TPoint;
  376.   PPointArray = ^TPointArray;
  377. begin
  378.   PPointArray(Msg.LParam)^[3].X := 300;
  379.   PPointArray(Msg.LParam)^[3].Y := 300;
  380. end;
  381.  
  382. { Changes the window's class name so an icon can be associated with
  383.   this window.
  384. }
  385. function TFontWindow.GetClassName: PChar;
  386. begin
  387.   GetClassName := 'OWLTrueTypeDemoWindow';
  388. end;
  389.  
  390. { Associates an icon with the window class.
  391. }
  392. procedure TFontWindow.GetWindowClass( var WC: TWndClass);
  393. begin
  394.   TWindow.GetWindowClass(WC);
  395.   WC.hIcon := LoadIcon(hInstance, PChar(id_Icon));
  396. end;
  397.  
  398. { When the window is resized, the size of the fonts may need to change.
  399.   This sets the Rendering flag so the Paint method can tell the user
  400.   that delays in painting are due to Windows generating new fonts.
  401. }
  402. procedure TFontWindow.WMSize(var Msg: TMessage);
  403. begin
  404.   TWindow.WMSize(Msg);
  405.   Rendering := True;
  406. end;
  407.  
  408.  
  409.  
  410. { Constructs the an instance of TFontWindow as the TFontApp's
  411.   MainWindow object.
  412. }
  413. procedure TFontApp.InitMainWindow;
  414. begin
  415.   MainWindow := New(PFontWindow, Init(nil, Application^.Name));
  416. end;
  417.  
  418.  
  419. { Main program }
  420.  
  421. begin
  422.   App.Init(DemoTitle);
  423.   App.Run;
  424.   App.Done;
  425. end.
  426.